home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue51 / SafeCall / TestSafeCallU.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1999-08-20  |  3.5 KB  |  162 lines
  1. unit TestSafeCallU;
  2.  
  3. {$ifdef Ver80} { Delphi 1.0x }
  4.   {$define DelphiLessThan2}
  5.   {$define DelphiLessThan3}
  6. {$endif}
  7. {$ifdef Ver90} { Delphi 2.0x }
  8.   {$define DelphiLessThan3}
  9. {$endif}
  10. {$ifdef Ver93} { C++ Builder 1.0x }
  11.   {$define DelphiLessThan3}
  12. {$endif}
  13. {$ifdef DelphiLessThan3}
  14.   'Safecall not supported before Delphi 3'
  15. {$endif}
  16.  
  17. interface
  18.  
  19. uses
  20.   comobj,
  21.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  22.   StdCtrls, Db, Grids, DBGrids, DBTables;
  23.  
  24. type
  25.   TForm1 = class(TForm)
  26.     Table1: TTable;
  27.     DBGrid1: TDBGrid;
  28.     DataSource1: TDataSource;
  29.     CheckBox1: TCheckBox;
  30.     Button1: TButton;
  31.     Button2: TButton;
  32.     Button3: TButton;
  33.     Button4: TButton;
  34.     procedure CheckBox1Click(Sender: TObject);
  35.     procedure Button1Click(Sender: TObject);
  36.     procedure Button2Click(Sender: TObject);
  37.     procedure Button3Click(Sender: TObject);
  38.     procedure Button4Click(Sender: TObject);
  39.   private
  40.     procedure DoSomething; safecall;
  41.   public
  42.     function SafeCallException(ExceptObject: TObject;
  43.       ExceptAddr: Pointer): HResult; override;
  44.   end;
  45.  
  46. var
  47.   Form1: TForm1;
  48.  
  49. implementation
  50.  
  51. {$R *.DFM}
  52.  
  53. uses
  54.   BDE;
  55.  
  56. var
  57.   EClass: ExceptClass = nil;
  58.   EMsg: String;
  59.  
  60. procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer);
  61. begin
  62.   //Must raise exception, but if SafeCallException handled
  63.   //the problem, we'll raise a "silent" exception
  64.   if EClass <> nil then
  65.     raise EClass.Create(EMsg)
  66.   else
  67.     SysUtils.Abort
  68. end;
  69.  
  70. procedure LogError(ExceptObject: Exception; ExceptAddr: Pointer);
  71. var
  72.   Log: TextFile;
  73. const
  74.   LogName = 'C:\DelphiLog.Txt';
  75. begin
  76.   AssignFile(Log, LogName);
  77.   if FileExists(LogName) then
  78.     Append(Log)
  79.   else
  80.     Rewrite(Log);
  81.   try
  82.     WriteLn(Log, Format('%s'#9'%s'#9'$%p'#9'%s',
  83.       [ExceptObject.ClassName, ExceptObject.Message,
  84.        ExceptAddr, Application.ExeName]))
  85.   finally
  86.     CloseFile(Log)
  87.   end;
  88. end;
  89.  
  90. function TForm1.SafeCallException(ExceptObject: TObject;
  91.   ExceptAddr: Pointer): HResult;
  92. var
  93.   Handled: Boolean;
  94. begin
  95.   Result := E_UNEXPECTED;
  96.   Handled := False;
  97.   if ExceptObject is EDBEngineError then
  98.   begin
  99.     Handled := True;
  100.     case EDBEngineError(ExceptObject).Errors[0].ErrorCode of
  101.       DBIERR_DETAILRECORDSEXIST:
  102.         ShowMessage('Delete/change detail records first...');
  103.       DBIERR_KEYVIOL:
  104.         ShowMessage('Already used that one')
  105.     else
  106.       Handled := False
  107.     end
  108.   end;                                                                  
  109.   LogError(Exception(ExceptObject), ExceptAddr);
  110.   if Handled then
  111.     EClass := nil
  112.   else
  113.   begin
  114.     EClass := ExceptClass(ExceptObject.ClassType);
  115.     EMsg := Exception(ExceptObject).Message
  116.   end
  117. end;
  118.  
  119. procedure TForm1.DoSomething;
  120. begin
  121.   Table1.Next
  122. end;
  123.  
  124. procedure TForm1.CheckBox1Click(Sender: TObject);
  125. begin
  126.   Table1.Active := CheckBox1.Checked
  127. end;
  128.  
  129. procedure TForm1.Button1Click(Sender: TObject);
  130. begin
  131.   DoSomething
  132. end;
  133.  
  134. procedure TForm1.Button2Click(Sender: TObject);
  135. begin
  136.   CheckBox1.Checked := False;
  137.   DoSomething
  138. end;
  139.  
  140. procedure TForm1.Button3Click(Sender: TObject);
  141. begin
  142.   Table1.Cancel;
  143.   Table1.First;
  144.   Table1.Edit;
  145.   Table1.FieldByName('CustNo').AsInteger := 1231;
  146.   DoSomething
  147. end;
  148.  
  149. procedure TForm1.Button4Click(Sender: TObject);
  150. begin
  151.   Table1.Cancel;
  152.   Table1.Insert;
  153.   Table1.FieldByName('CustNo').AsInteger := 1221;
  154.   DoSomething
  155. end;
  156.  
  157. initialization
  158.   SafeCallErrorProc := @SafeCallError;
  159. finalization
  160.   SafeCallErrorProc := nil;
  161. end.
  162.